Software Vault: The Diamond Collection/The Diamond Collection (Software Vault)(Digital Impact).ISO/cdr27/cldda100.zip/CAL-DDA.PAS

Pascal/Delphi Source File | 1995-02-01 | 15KB | 576 lines

PROGRAM Perpetual_Calendar;
USES DOS, CRT;

CONST MinYear = 0001;       (* arbitrary limits; broad enough for  *)
      MaxYear = 9999;       (*   for most practical cases purposes *)

      DaysPerYear = 365;
      DaysPerWeek = 7;

      Margin = 1;
      Between = 1;
      StartRow = 4;
      MaxDigits = 2;
      Width = 2 * Margin + DaysPerWeek * MaxDigits +
                          (DaysPerWeek-1) * Between + 2;

      IntenseFore = White;
      Fore    = Black;       RevFore = LightGray;   BorderFore = White;
      Back    = LightGray;   RevBack = Black;       BorderBack = LightGray;

 TYPE Month = (Jan, Feb, Mar, Apr, May, Jun, Jul, Aug, Sep, Oct, Nov, Dec);

      Date = RECORD
               da: 1..31;
               mo: Month;
               yr: MinYear..MaxYear
             END;

      DayType = (Sun, Mon, Tue, Wed, Thu, Fri, Sat);

 {-----------------------}
   {for the OpenWindow & CloseWindow procedures, which are by SALIM SAMAHA}

 Type
   ScreenImage = Array [0..7999] of Word;  { enough for 132*60 }
   FrameRec    = Record
     Upperleft    : Word;
     LowerRight   : Word;
     ScreenMemory : ScreenImage;
   end;

  VAR
    SnapShot   : ^ScreenImage;
    FrameStore : Array [1..10] of ^FrameRec;
    WindowNum  : INTEGER;
 {-----------------------}

  VAR maxDay: ARRAY [Month] OF INTEGER;
      daysBefore: ARRAY [Month] OF INTEGER;

      savedDate: Date;
      minDate, maxDate: Date;

   (* end of declarations *)

PROCEDURE Cursor(Const on : boolean);
  (*= The Cursor procedure is not attributable =*)
VAR
  r : registers;
BEGIN
  r.ah:=$03;            {----get cursor shape on page 0               }
  r.bh:=$00;            {----to be exact use function 2 to obtain page}
  intr($10,r);

  if ((r.cx< $2000) and not(on)) or
     ((r.cx>=$2000) and on)
    then
      begin
        r.ah:=$01;
        r.cx:=r.cx xor $2000;   {----toggle bit if neccesary}
        intr($10,r);
      end
END; {of cursor}

FUNCTION IsLeapYear(Const yr: INTEGER): BOOLEAN;
BEGIN
  IsLeapYear := ((yr MOD 4 = 0) AND (yr MOD 100 <> 0)) OR (yr MOD 400 = 0)
END;

FUNCTION NumDays(CONST d: Date): LONGINT;
  (* NumDays returns an ordinal value for the date
     with January 1, 0001 assigned the value 1.    *)
  VAR result, leapYears, lYr: LONGINT;
BEGIN
  WITH d DO BEGIN
    lYr:=yr-1;
    result := (da);
    INC(result, daysBefore[mo]);
    INC(result,lYr * DaysPerYear);
    leapYears := (lYr DIV 4) - (lYr DIV 100) + (lYr DIV 400);
    INC(result, leapYears);
    IF (mo > Feb) AND IsLeapYear(yr) THEN INC(result)
  END;
  NumDays := result
END;

PROCEDURE MakeDate(Const n: LONGINT; VAR d: Date);
  (* Takes an ordinal value compatible with that
     returned by NumDays and forms the corresponding
     date in d.                                      *)

  FUNCTION Before(Const mo: Month; Const yr: INTEGER): INTEGER;
    (* This routine is the procedure equivalent of
       the daysBefore array - except that it corrects
       for leap years.                                *)
    VAR i, max: Month;
        result: INTEGER;
  BEGIN
    result := 0;
    IF mo <> Jan THEN BEGIN
      max := mo;
      system.DEC(max);
      FOR i := Jan TO max DO
        INC(result, maxDay[i]);
      IF (max > Jan) AND IsLeapYear(yr) THEN
        INC(result)
    END;
    Before:=result
  END;

  VAR c: INTEGER;
      i: LONGINT;
BEGIN
  WITH d DO BEGIN
    mo := Dec;
    da := 31;
    yr := n DIV DaysPerYear;
    i := NumDays(d);
    WHILE i >= n DO BEGIN
      system.DEC(yr);
      i := NumDays(d)
    END;
    INC(yr);
    c := n - i;
    WHILE (mo > Jan) AND (Before(mo, yr) >= c) DO
      system.DEC(mo);
    system.DEC(c, Before(mo, yr));
    da := c
  END
END;

FUNCTION DayOfWeekF(Const d: Date): DayType;
BEGIN
  DayOfWeekF:= DayType(NumDays(d) MOD DaysPerWeek)
END;

PROCEDURE WrMonth(Const mo: Month);
  VAR s: string[3];
BEGIN
  CASE mo OF
    Jan: s := 'Jan';
    Feb: s := 'Feb';
    Mar: s := 'Mar';
    Apr: s := 'Apr';
    May: s := 'May';
    Jun: s := 'Jun';
    Jul: s := 'Jul';
    Aug: s := 'Aug';
    Sep: s := 'Sep';
    Oct: s := 'Oct';
    Nov: s := 'Nov';
    Dec: s := 'Dec';
  END;
  Write(s)
END;

FUNCTION LastDay(Const mo: Month; Const yr: INTEGER): INTEGER;
  VAR da: INTEGER;
BEGIN
  da := maxDay[mo];
  IF (mo = Feb) AND IsLeapYear(yr) THEN INC(da);
  LastDay := da
END;

PROCEDURE DispDay(Const pos0: INTEGER; Const d: Date);
  VAR x, y: INTEGER;
BEGIN
  x := Margin + ORD(DayOfWeekF(d)) * (MaxDigits+Between) + 1;
  y := (d.da + pos0 - 1) DIV DaysPerWeek + StartRow;
  GotoXY(x+1, y+1);
  Write(d.da: MaxDigits)
END;

PROCEDURE HiLite(Const pos0: INTEGER; Const d: Date);
BEGIN
  TextColor(RevFore);
  TextBackGround(RevBack);
    DispDay(pos0, d);
  TextColor(Fore);
  TextBackGround(Back)
END;

PROCEDURE OpenWindow(Const UpLeftX, UpLeftY, LoRightX, LoRightY : INTEGER);
  (*= The OpenWindow procedure is by SALIM SAMAHA, from SWAG =*)
BEGIN
  SnapShot := Ptr($B800, $0000);
  Inc(WindowNum);
  New(FrameStore[WindowNum]);
  With Framestore[WindowNum]^ do
  begin
    ScreenMemory := SnapShot^;
    UpperLeft    := WindMin;
    LowerRight   := WindMax;
  end;
  Window(UpLeftX, UpLeftY, LoRightX, LoRightY);
END;

PROCEDURE CloseWindow;
  (*= The CloseWindow procedure is by SALIM SAMAHA, from SWAG =*)
BEGIN
  With Framestore[WindowNum]^ do
  begin
    Snapshot^ := ScreenMemory;
    Window ((Lo(UpperLeft) + 1), (Hi(UpperLeft) + 1),
            (Lo(LowerRight) + 1), (Hi(LowerRight) + 1));
  end;
  Dispose(Framestore[WindowNum]);
  system.Dec(WindowNum);
END;

PROCEDURE writechar (Const c : CHAR; Const attr, x, y : INTEGER); assembler;
  (*= The writechar procedure is by John Giesbrect, from SWAG =*)

(*  assumes video page 0
 *  upper left-hand corner is (1, 1)
 *)
ASM
  mov ax, $0300   (* get cursor position *)
  XOR bh, bh
  INT $10
  push dx         (* and save it *)
  mov ax, $0200   (* set cursor position *)
  XOR bh, bh
  mov dh, BYTE PTR y
  DEC dh
  mov dl, BYTE PTR x
  DEC dl
  INT $10
  mov ah, $09     (* write char and attribute *)
  mov al, BYTE PTR c
  XOR bh, bh
  mov bl, BYTE PTR attr
  mov cx, $0001
  INT $10         (* restore original cursor position *)
  mov ax, $0200
  XOR bh, bh
  pop dx
  INT $10
END;

PROCEDURE DisplayBorder(Const Left,Top,Rit,Bot,BoxSty : INTEGER);
  (*= The DisplayBorder procedure is by DDA =*)
Const
  BoxChars=
    #032#032#032#032#032#032+ {'      ' 0 - spaces (no boxes)            }
    #218#196#191#179#192#217+ {'┌─┐│└┘' 1 - single-line characters       }
    #213#205#184#179#212#190+ {'╒═╕│╘╛' 2 - single-line side, double top }
    #214#196#183#186#211#189+ {'╓─╖║╙╜' 3 - double-line side, single top }
    #201#205#187#186#200#188; {'╔═╗║╚╝' 4 - double-line characters       }
VAR
  ic : INTEGER;
  Box : string[6];
BEGIN
  Box:=Copy(BoxChars,1+(6*BoxSty),6);
    writechar(Box[1],TextAttr,Left,Top);
  FOR ic := (Succ (Left)) to (Pred (Rit)) DO
    writechar(Box[2],TextAttr,ic,Top);
    writechar(Box[3],TextAttr,Rit,Top);
  FOR ic := (Succ (Top)) to (Pred (Bot)) DO
    writechar(Box[4],TextAttr,Left,ic);
    writechar(Box[5],TextAttr,Left,Bot);
  FOR ic := (Succ (Left)) to (Pred (Rit)) DO
    writechar(Box[2],TextAttr,ic,Bot);
  FOR ic := (Succ (Top)) to (Pred (Bot)) DO
    writechar(Box[4],TextAttr,Rit,ic);
    writechar(Box[6],TextAttr,Rit,Bot);
END;

PROCEDURE Open_Window;
  VAR Depth, Lft, Top, Rgt, Btm, BoxStyle : INTEGER;
BEGIN
  Depth := 6 + 2 + StartRow - 1;
  Lft := ((1 + Lo(WindMax) - Width) DIV 2) + 1;
  Top := ((1 + Hi(WindMax) - Depth) DIV 2) + 1;
  Rgt := Lft + Width - 1;
  Btm := Top + Depth - 1;
  OpenWindow(Lft,Top,Rgt,Btm);
  TextBackGround(Back);
  ClrScr;
  TextColor(BorderFore);
  TextBackGround(BorderBack);
  BoxStyle:=4;
  DisplayBorder(Lft,Top,Rgt,Btm,BoxStyle);
  Cursor(FALSE);
  TextColor(Fore);
  TextBackGround(Back);
  GotoXY(((Width-8) DIV 2), Depth);
  Write(' F1: help ')
END;

PROCEDURE DispCalendar(d: Date; Const startPos: INTEGER);

  PROCEDURE WrHeading;
    CONST MonthCol = 1+((Width-2) - 8) DIV 2 + 1;
          DayLetter : String[7] = 'SMTWTFS';
    VAR i: INTEGER;
  BEGIN
    GotoXY(MonthCol, 2);
    WrMonth(d.mo);
    Write(d.yr: 5);
    WriteLn; WriteLn;

    TextColor(IntenseFore);
    GotoXY(Margin+3,WhereY);
    Write (DayLetter[1]);

    FOR i := 2 TO DaysPerWeek DO BEGIN
      Write (' ':Between+1);
      Write (DayLetter[i])
    END;

    TextColor(Fore);
    WriteLn
  END;

  VAR i, max: INTEGER;
      x1,y1,x2,y2 : INTEGER;
BEGIN
  x1:=1+Lo(WindMin); y1:=1+Hi(WindMin);
  x2:=1+Lo(WindMax); y2:=1+Hi(WindMax);
  Window(x1+1,y1+1,x2-1,y2-1); ClrScr; Window(x1,y1,x2,y2);

  WrHeading;
  max := LastDay(d.mo, d.yr);
  FOR i := 1 TO max DO BEGIN
    d.da := i;
    DispDay(startPos, d)
  END
END;

PROCEDURE IncDate(VAR d: Date; Const n: LONGINT);
  (* Increments the date by the value n. *)
  VAR i: LONGINT;
BEGIN
  WITH d DO BEGIN
    i := NumDays(d);
    INC(i, n);
    MakeDate(i, d)
  END
END;

PROCEDURE DecDate(VAR d: Date; Const n: LONGINT);
  (* Decrements the date by the value n. *)
  VAR i: LONGINT;
BEGIN
  WITH d DO BEGIN
    i := NumDays(d);
    system.DEC(i, n);
    MakeDate(i, d)
  END
END;

PROCEDURE ShowHelp; Forward;

PROCEDURE HandleScanCode(Const pos0: INTEGER; VAR d: Date; VAR refresh: BOOLEAN);
  CONST (* scan codes *)
        home  = #71; up    = #72; pgUp  = #73;
        left  = #75;              right = #77;
                     down  = #80; pgDn  = #81;
        F1 = #59;
        ctrlPgUp = #132;
        ctrlPgDn = #118;

  VAR sc: CHAR; (* scan code *)
      d0: Date; (* date on entry *)
      max: INTEGER;
BEGIN
  d0 := d;
  sc := ReadKey;
  CASE sc OF
    F1:
      ShowHelp;
    left:
      IF NumDays(d) > NumDays(minDate) THEN BEGIN
        DispDay(pos0, d);
        DecDate(d, 1);
        HiLite(pos0, d)
      END;
    right:
      IF NumDays(d) < NumDays(maxDate) THEN BEGIN
        DispDay(pos0, d);
        IncDate(d, 1);
        HiLite(pos0, d)
      END;
    up:
      IF NumDays(d) >= (NumDays(minDate) + DaysPerWeek) THEN BEGIN
        DispDay(pos0, d);
        DecDate(d, DaysPerWeek);
        HiLite(pos0, d)
      END;
    down:
      IF (NumDays(d) + DaysPerWeek) <= NumDays(maxDate) THEN BEGIN
        DispDay(pos0, d);
        IncDate(d, DaysPerWeek);
        HiLite(pos0, d)
      END;
    pgUp:
      BEGIN
        IF d.mo > Jan THEN system.DEC(d.mo)
        ELSE BEGIN
          IF d.yr > MinYear THEN BEGIN
            system.DEC(d.yr);
            d.mo := Dec
          END;
        END;
        max := LastDay(d.mo, d.yr);
        IF d.da > max THEN d.da := max;
      END;
    pgDn:
      BEGIN
        IF d.mo < Dec THEN INC(d.mo)
        ELSE BEGIN
          IF d.yr < MaxYear THEN BEGIN
            INC(d.yr);
            d.mo := Jan
          END
        END;
        max := LastDay(d.mo, d.yr);
        IF d.da > max THEN d.da := max;
      END;
    ctrlPgUp:
      IF d.yr > MinYear THEN BEGIN
        system.DEC(d.yr);
        IF (d.mo = Feb) AND (d.da = 29) THEN
          d.da := LastDay(d.mo, d.yr);
      END;
    ctrlPgDn:
      IF d.yr < MaxYear THEN BEGIN
        INC(d.yr);
        IF (d.mo = Feb) AND (d.da = 29) THEN
          d.da := LastDay(d.mo, d.yr)
      END;
    home:
      BEGIN
        DispDay(pos0, d);
        d := savedDate;
        HiLite(pos0, d)
      END;
  END;
  refresh := (d.mo <> d0.mo) OR (d.yr <> d0.yr)
END;

PROCEDURE GetSelDate(VAR d: Date);
(* General routine that allows the user to select
   a date by positioning a "cursor" on the desired
   date and pressing return; if <Esc> is pressed,
   the date is left unchanged and abort becomes TRUE.

   d should be seeded with a valid date, which will
   determine the starting date upon calling the
   procedure.                                         *)

  CONST nul = #0;
        cr  = #13;
        esc = #27;
  VAR ch: CHAR;
      refresh: BOOLEAN;      (* rebuild display *)
      startPos: INTEGER;    (* horizontal offset *)
      savedDay: INTEGER;
BEGIN
  savedDate := d;
  Open_Window;
  refresh := TRUE;
  REPEAT
    IF refresh THEN BEGIN
      savedDay := d.da;
      d.da := 1;
      startPos := ORD(DayOfWeekF(d));
      d.da := savedDay;
      DispCalendar(d, startPos);
      HiLite(startPos, d)
    END;
    ch := ReadKey;
    IF ch = nul THEN HandleScanCode(startPos, d, refresh)
  UNTIL (ch = esc) OR (ch = cr);

  IF (ch = esc) THEN d := savedDate;
  CloseWindow
END;

PROCEDURE InitMax;
BEGIN
  WITH minDate DO BEGIN
    mo := Jan;
    da := 1;
    yr := MinYear
  END;
  WITH maxDate DO BEGIN
    mo := Dec;
    da := 31;
    yr := MaxYear
  END
END;

PROCEDURE MonthsInit;
  VAR mo: Month;
BEGIN
  maxDay[Jan] := 31;
  maxDay[Feb] := 28;  (* adjust for leap years later *)
  maxDay[Mar] := 31;
  maxDay[Apr] := 30;
  maxDay[May] := 31;
  maxDay[Jun] := 30;
  maxDay[Jul] := 31;
  maxDay[Aug] := 31;
  maxDay[Sep] := 30;
  maxDay[Oct] := 31;
  maxDay[Nov] := 30;
  maxDay[Dec] := 31;

  daysBefore[Jan] := 0;
  FOR mo := Jan TO Nov DO
    daysBefore[Month(ORD(mo)+1)] := daysBefore[mo] + maxDay[mo]
END;

PROCEDURE GetSysDate(VAR d: Date);
  (* Reads the system clock and assigns the date to d
     and the day of the week to dayOfWeek.            *)
  VAR SysYear,SysMonth,SysDay,SysDOW : word;
BEGIN
  GetDate(SysYear,SysMonth,SysDay,SysDOW);
  d.yr := SysYear;
  d.mo := Month(SysMonth-1);
  d.da := SysDay
{ dayOfWeek := DayType(SysDOW+1);   }
END;

PROCEDURE Wrl(Const s : String);
BEGIN
  WriteLn(s);
END;

PROCEDURE ShowHelp;
  VAR tkey : char;
BEGIN
  OpenWindow(2+Lo(WindMin),2+Hi(WindMin),Lo(WindMax),Hi(WindMax));
  ClrScr;
  GotoXY(1,1);
    Wrl('Free calendar (by DDA)');

    Wrl('Date:  '#27#32#26);
    Wrl('Week:  '#24#32#25);
    Wrl('Month: PgUp/ PgDn');
    Wrl('Year:  Ctrl-PgUp/ PgDn');

    Wrl('Current date: Home');
    Write('Exit:  Escape');
  tkey:=ReadKey;
  if tkey=#0 then ReadKey;
  CloseWindow;
END;

  VAR d: Date;
      x, y : integer;

BEGIN
  x:=WhereX; y:=WhereY;
  MonthsInit;
  InitMax;
  WindowNum:=1;
  GetSysDate(d);
  GetSelDate(d);
  GotoXY (x,y);
  Cursor(TRUE);
END.